---
title: "Demand Forecasting"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
source_code: embed
---
```{r setup, include=FALSE}
```
```{r libraries, include=FALSE}
library(flexdashboard)
library(odbc)
library(DBI)
library(RSQLite)
library(tidyverse)
library(tictoc)
library(lubridate)
library(assertthat)
library(plotly)
library(leaflet)
library(geosphere)
library(highcharter)
library(TTR)
library(downloadthis)
library(fpp3)
library(lsa)
```
```{r parameters}
db_path = file.path("..", "..", "data", "m0", "raw", "raw_sca.db")
deliverable_db_path = file.path("..", "..","data", "results", "del_sca.db")
geo_codes_path = file.path("..","..","data","m0","raw","geonames-all-cities-with-a-population-1000.csv")
```
```{r udf}
euro <- scales::dollar_format(prefix="\u20ac",suffix = "")
```
```{r DB connections}
raw_con <- dbConnect(RSQLite::SQLite(), db_path)
del_con <- dbConnect(RSQLite::SQLite(), deliverable_db_path)
```
```{r save tables}
#dbListTables(conn = del_con)
del_tbl = tbl(src = del_con, "currentProductSegmentation")
raw_tbl = tbl(src = raw_con, "salesUpdated")
# Coords
# retrieved from https://public.opendatasoft.com/explore/dataset/geonames-all-cities-with-a-population-1000/map/?disjunctive.cou_name_en&sort=name&refine.timezone=Europe%2FRome&location=6,44.48328,9.76685&basemap=jawg.light
geocode = read.csv(geo_codes_path, sep = ";")
```
```{r store datasets}
past_quarters = del_tbl %>% collect()
sales_updated = raw_tbl %>% collect()
```
# Demand {data-orientation="rows" data-navmenu="M1"}
## Row
### Elapsed quarters
```{r}
last_update = sales_updated %>%
pull(SalesDate) %>%
unique() %>%
as_date() %>%
max()
current_date = Sys.Date() - days(Sys.Date() - last_update)
year_start = as_date(paste0(year(current_date), "-01-01"))
time = data.frame(SalesDate = seq(year_start,
current_date,
by = "day")) %>%
mutate(quarters = quarter(SalesDate),
is_current_quarter = quarter(SalesDate) == quarter(Sys.Date()))
elapsed_quarters = time %>%
filter(is_current_quarter == F) %>%
pull(quarters) %>%
unique() %>%
length()
valueBox(value = elapsed_quarters,
icon = "fa-calendar-days",
col = "primary")
```
### Total Days in selected quarters
```{r}
time_span = time %>%
filter(is_current_quarter == F) %>%
nrow()
valueBox(value = time_span,
icon = "fa-calendar-day",
col = "primary")
```
### Selected Warehouse
```{r}
current_warehouse = sales_updated %>%
pull(Warehouse) %>%
unique() %>%
word(start = 2, sep = " ")
valueBox(value = current_warehouse,
icon = "fa-warehouse",
col = "warning")
```
### Revenue
```{r}
# Here we didn't remove the cancelled orders so this quantity is inflated
# We need to correct it in the next iteration
revenue = del_tbl %>%
pull(Revenue) %>%
sum()
valueBox(value = euro(revenue),
icon = "fa-briefcase",
col = "success")
```
### Consolidated Consumption Value (CCV)
```{r}
acv = past_quarters %>% pull(cost) %>% sum()
flexdashboard::valueBox(value = euro(acv),
icon = "fa-briefcase",
col="danger")
dbDisconnect(conn = del_con)
dbDisconnect(conn = raw_con)
```
### Margin
```{r}
# Revenue has the cancelled orders inside so this is correct
# Correcting Revenue will solve this problem
nr = past_quarters %>% pull(Net_Revenue) %>% sum()
flexdashboard::valueBox(value = euro(nr),
icon = "fa-sack-dollar",
col = "success")
```
## Row
### Demand Map
```{r}
# Filter the coords dataset to keep only stores referring to the current warehouse
stores = sales_updated$Store %>% unique()
geocode = geocode %>%
filter(toupper(Name) %in% stores) %>%
mutate(status = ifelse(current_warehouse == Name,
"Warehouse",
"Store"),
radius = ifelse(status == "Warehouse", 12, 6)) %>%
separate(Coordinates, into = c("coord_a", "coord_b"), sep = ",", convert = T,
remove = F) %>%
rename(city = Name)
# ATM we're displaying population,
# but in future we should display the number of orders by store
# the same for popup. Now it shows the name of the city
# but we can do somethin else
geocode %>%
leaflet() %>%
addTiles() %>%
setView(lng = 11.3426,
lat = 44.4949,
zoom = 5) %>%
addCircles(lng = ~ coord_b,
lat = ~ coord_a,
weight = 1,
radius = ~ sqrt(Population) * 30,
color = ~ ifelse(status == "Warehouse", "red", "blue"),
popup = ~ city,
group = ~ status) %>%
addLayersControl(overlayGroups = ~ status,
options = layersControlOptions(collapsed = F))
```
### Demand
```{r}
# ATM we are not checking if there are missing dates
# I think that is good actually, because that would a closed store
orders_data = sales_updated %>%
dplyr::select(SalesDate, UnitsSold) %>%
group_by(SalesDate) %>%
summarise(n = sum(UnitsSold)) %>%
mutate(SMA = SMA(n),
EMA = EMA(n),
SalesDate = as_date(SalesDate),
RSI = RSI(n),
RSI_sell= 70,
RSI_buy=30)
# Computing complex metrics like bollinger bands and macd
bb = BBands(orders_data$n) %>% as_tibble()
names(bb) = paste("bb", names(bb), sep = "_")
macd = MACD(orders_data$n) %>% as_tibble() %>% rename(macd_signal = signal)
# Aggregating data in a dataframe
orders_data = bind_cols(orders_data, bb, macd)
rm(bb, macd)
# Plot it
chart = highchart(type = "stock") %>%
hc_yAxis_multiples(create_yaxis(3, heigth = c(2,1,1), turnopposite = T)) %>%
hc_add_series(orders_data, yAxis = 0, "line", hcaes(x=SalesDate, y = n), name = "Demand") %>%
hc_add_series(orders_data, yAxis = 0, "line", hcaes(x=SalesDate, y = EMA), name = "EMA", color = "#FF0000") %>%
hc_add_series(orders_data,yAxis = 0, "arearange", hcaes(x = SalesDate,
low = bb_dn,
high = bb_up),
name = "Bollinger Bands", color = "#2DFF00", fillOpacity = 0.1,
lineWidth = 0.5) %>%
hc_add_series(orders_data, "line", yAxis = 1, hcaes(x=SalesDate, y=macd), name = "MACD", color="orange") %>%
hc_add_series(orders_data, "line", yAxis = 1, hcaes(x=SalesDate, y=macd_signal), name = "Signal", color="purple") %>%
hc_add_series(orders_data, "line", yAxis = 2, hcaes(x=SalesDate, y=RSI), name = "RSI", color = "dodgerblue") %>%
hc_add_series(orders_data, "line", yAxis = 2, hcaes(x=SalesDate, y=RSI_sell), name = "Sell", color = "red") %>%
hc_add_series(orders_data, "line", yAxis = 2, hcaes(x=SalesDate, y=RSI_buy), name = "Buy", color = "yellow") %>%
# hc_yAxis(title = list("Units sold"),
# opposite = FALSE) %>%
hc_rangeSelector(selected = 5, selected = 2) %>%
hc_tooltip(valueDecimals = 2, split = TRUE) %>%
hc_navigator(enabled = T) %>%
hc_scrollbar(enabled = T)
chart
```
# Product Segmentation {data-orientation="columns" data-navmenu="M1"}
## column
### ABC-XYZ Segmentation
```{r}
past_quarters %>%
mutate(abc_xyz = paste(multi_class_descriptor,
xyz_class_descriptor,
sep = "-")) %>%
xtabs(~ abc_xyz, data = .) %>%
as_tibble() %>%
plot_ly(data = .) %>%
add_pie(labels = ~ abc_xyz, values = ~ n, hole = 0.5)
```
### Additional info {data-height="30"}
```{r}
## Download button for the emotional people
# src: https://fmmattioni.github.io/downloadthis/reference/download_this.html
past_quarters %>%
relocate(Category, Supplier, Series, Article, .after = SKU) %>%
download_this(output_name = "Product segmentation",
output_extension = ".xlsx")
```
## column
### ABC Segmentation
```{r}
past_quarters %>%
xtabs(~ multi_class_descriptor, data = .) %>%
as_tibble() %>%
plot_ly(data = .) %>%
add_pie(labels = ~ multi_class_descriptor, values = ~ n, hole = 0.5)
```
### XYZ Segmentation
```{r}
past_quarters %>%
xtabs(~ xyz_class_descriptor, data = .) %>%
as_tibble() %>%
plot_ly(data = .,
marker = list(colors = c("orange", "firebrick", "#118a0c")
)) %>%
add_pie(labels = ~ xyz_class_descriptor, values = ~ n, hole = 0.5)
```
# Forecast {data-orientation="rows" data-navmenu="M2"}
## Row
### Model forecast for the next 10 days
```{r}
load("demo.rdata")
valueBox(value = best_model_forecast,
icon = "fa-box",
col = "success")
```
### Forecast is valid from this date
```{r}
valueBox(value = last_update,
icon = "fa-calendar-day",
col = "success")
```
### Forecast validity ends here
```{r}
valueBox(value = last_update + days(10),
icon = "fa-calendar-day",
col = "warning")
```
### Days in the test set
```{r}
valueBox(value = 10,
icon = "fa-calendar-days",
col = "primary")
```
### Root Mean Squared Errors of best model (RMSE)
```{r}
rms = model_evaluation %>%
filter(best_model == T) %>%
pull(RMSE)
valueBox(value = round(rms,2),
icon = "fa-xmark",
col = "danger")
```
### Forecast ensamble cosine similarity
```{r}
# We use average cosine similarity as a measure of concordance
# between the forecast of different models
# Define your five values as a numeric vector
values <- model_evaluation$test_sales_forecast_horizon
# Create a matrix with all pairwise combinations of values
mat <- combn(values, 2)
# Calculate cosine similarity
cosine_sim <- lsa::cosine(mat)
# Find the maximum similarity score for cosine similarity
max_cosine_sim <- max(cosine_sim)
avg_cosine_sim <- mean(cosine_sim)
valueBox(value = round(avg_cosine_sim,2),
icon = "fa-thumbs-up",
col = "success")
```
## Row
### Demand
```{r}
load("demo.rdata")
chart
```
### Forecast Error
```{r}
fe
```
# Decomposition {data-orientation="rows" data-navmenu="M2"}
## Row
### Is this a random walk?
```{r}
load("demo stl.rdata")
if (description$is_random_walk) {
valueBox(value = "TRUE",
icon = "fa-thumbs-down",
col = "danger")
} else {
valueBox(value = "FALSE",
icon = "fa-thumbs-up",
col = "success")
}
```
### Is this white noise?
```{r}
load("demo stl.rdata")
if (description$is_white_noise) {
valueBox(value = "TRUE",
icon = "fa-thumbs-down",
col = "danger")
} else {
valueBox(value = "FALSE",
icon = "fa-thumbs-up",
col = "success")
}
```
### Is this autocorrelated?
```{r}
if (description$is_autocorrelated != "not autocorrelated") {
valueBox(value = "TRUE",
icon = "fa-thumbs-up",
col = "success")
} else {
valueBox(value = "FALSE",
icon = "fa-thumbs-down",
col = "warning")
}
```
### Seasonality strength (0-1)
```{r}
valueBox(value = round(description$seasonal_strength_week, 2),
icon = "fa-arrow-trend-up",
col = "primary")
```
### Trend strength (0-1)
```{r}
valueBox(value = round(description$trend_strength, 2),
icon = "fa-arrow-trend-up",
col = "primary")
```
### Zero sales proportion (0-1)
```{r}
valueBox(value = round(description$zero_sales_proportion, 2),
icon = "fa-empty-set",
col = "danger")
```
## Row
### STL Decomposition
```{r}
stl_plot
```
### Autocorrelation Function
```{r}
acf_plot
```
# Forecast Dashboard {data-orientation="columns" data-navmenu="M2"}
## column
### Forecast error proportion
```{r}
load("demo_overallmodels.rdata")
plot_a
```
### Additional info {data-height="30"}
```{r}
## Download button for the emotional people
# src: https://fmmattioni.github.io/downloadthis/reference/download_this.html
toplot %>%
download_this(output_name = "Product segmentation",
output_extension = ".xlsx")
```
## column
### Error Distribution
```{r}
plot_b
```
### Impact on sales
```{r}
plot_c
```
